Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/allowo1g/listtoht.cls

Visual Basic class definition | 1999-08-27 | 7.0 KB | 201 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ListToHTML"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Description = "Routines to convert a list to an HTML table"
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
' ListToHTML.cls    July 1999 contact [e-mail]
' Encapsulates a method to convert a tab-delimited text file into an HTML Table.
' Reports progress by raising an Event.
' Requires Project/References entry for
'   Microsoft HTML Object Library (MSHTML.tlb)
'
' NOTE: The purpose is to demonstrate DOM manipulation. The Tabular Data Control
'       (TDC.ocx) is a good solution for displaying delimited text files.
'=================================================================================
' Events
Public Event RowProgress(RowNum As Long)                ' Once at start of processing
Public Event RowsCols(NumRows As Long, NumCols As Long) ' Frequency = ProgressInterval
'Module-level variables to hold property values
Private mvarListCaption As String       ' no default
Private mvarProgressInterval As Long    ' default = 5
Private mvarCancel As Boolean           ' allows interruption of main processing loop
' Module-level variables
Private mFootText As String

Public Property Let ListCaption(ByVal vData As String)  ' Optional
    mvarListCaption = vData
End Property

Public Property Let ProgressInterval(ByVal vData As Long)   ' Default = 5
    mvarProgressInterval = vData
End Property

Public Property Let Cancel(ByVal vData As Boolean)
    mvarCancel = vData
    mFootText = "PROCESS CANCELLED - list may be incomplete"
End Property

Public Function FileToDOM( _
            InFileName As String, _
            HTMLDoc As MSHTML.HTMLDocument, _
            Optional GetTotalRows As Boolean = False) As MSHTML.HTMLTable

    On Error GoTo FileToDOM_Error

    Const sngZero As Single = 0

    Dim Result As MSHTML.HTMLTable
    Dim oTable As MSHTML.HTMLTable
    Dim oTBody As MSHTML.HTMLTableSection
    Dim oRow As MSHTML.HTMLTableRow
    Dim oRowClone As MSHTML.HTMLTableRow
    Dim oCol As MSHTML.HTMLTableCol
    Dim oCell As MSHTML.HTMLTableCell
    Dim IsNumCol() As Boolean   ' attempt to speed numeric test in BODY loop
    Dim rowIX As Long, rowIXmax As Long
    Dim colIX As Long, colIXmax As Long
    Dim InFile As Scripting.TextStream
    Dim varCols As Variant
    Dim strCell As String

' Open input file
    With New Scripting.FileSystemObject

    ' Read ahead to second line (first line of data)
        With .OpenTextFile( _
                FileName:=InFileName, _
                IOMode:=ForReading)
            .ReadLine   ' skip headings line
            varCols = Split(.ReadLine, vbTab)   ' first row of data
            If GetTotalRows Then ' If requested, pre-read file to get total rows
                rowIXmax = 2
                Do Until .AtEndOfStream
                    .ReadLine
                    rowIXmax = rowIXmax + 1
                Loop
            End If
            .Close
        End With

    ' Re-open file for main loop
        Set InFile = .OpenTextFile( _
                FileName:=InFileName, _
                IOMode:=ForReading)
    End With

' Keep range dimensions in local variables (see above for rowIXmax; may be zero)
    colIXmax = UBound(varCols)
    RaiseEvent RowsCols(rowIXmax, colIXmax + 1)

' Create row for cloning
    With HTMLDoc
        Set oRow = .createElement("TR")
        For colIX = 0 To colIXmax
            Set oCell = oRow.appendChild(.createElement("TD"))
            oCell.appendChild .createTextNode(" ")
        Next
    End With

' Create the Table Object
    Set oTable = HTMLDoc.createElement(etag:="TABLE")
    oTable.id = "idTable"

' Column specifications (Not foolproof; blank field in first row always non-numeric)
    ReDim IsNumCol(0 To colIXmax)
    For colIX = 0 To colIXmax   ' in first row of data (line 2)
        Set oCol = oTable.appendChild(HTMLDoc.createElement("COL"))
        IsNumCol(colIX) = IsNumeric(varCols(colIX))
        oCol.className = IIf(IsNumCol(colIX), "clNum", "clText") ' Does not render ??
    Next colIX

' Body
    Set oTBody = oTable.appendChild(HTMLDoc.createElement("TBODY"))
    Do Until InFile.AtEndOfStream
        varCols = Split(InFile.ReadLine, vbTab)
        rowIX = rowIX + 1
        Set oRowClone = oTBody.appendChild(oRow.cloneNode(fdeep:=True))
        For colIX = 0 To colIXmax
            strCell = varCols(colIX)
            Set oCell = oRowClone.childNodes(colIX)
            With oCell
                .firstChild.nodeValue = strCell
                If IsNumCol(colIX) Then
                    .runtimeStyle.TextAlign = "right"   ' clNum Does not render ??
                    If IsNumeric(strCell) Then  ' beter than Len(strCell) > 0
                        If CSng(strCell) < sngZero Then
                            .className = "clNumNeg"
                            .runtimeStyle.Color = "red" ' clNumNeg Does not render ??
                        End If
                    End If
                End If
            End With
        Next colIX
        If rowIX Mod mvarProgressInterval = 0 Then
            RaiseEvent RowProgress(rowIX)
            If mvarCancel Then
                Beep
                Exit Do
            End If
        End If
    Loop    ' on Infile
    InFile.Close

' Header Row: use first row as column headings (i.e., move from TBODY to THEAD)
    With oTable.createTHead
        .appendChild oTBody.firstChild
    End With

' Footer Row
    With oTable.createTFoot
        With .appendChild(HTMLDoc.createElement("TR"))
            With .appendChild(HTMLDoc.createElement("TD"))
                .colSpan = colIXmax + 1
                .appendChild HTMLDoc.createTextNode(mFootText)
                If mvarCancel Then
                .runtimeStyle.backgroundColor = "red"
                End If
            End With
        End With
    End With

' Caption (if ListCaption Property is specified)
    If Len(mvarListCaption) Then
        With oTable.createCaption
            .appendChild HTMLDoc.createTextNode(mvarListCaption)
            .runtimeStyle.display = "inline"
        End With
    End If

    RaiseEvent RowProgress(rowIX)
    Set Result = oTable

FileToDOM_Exit:
    Set FileToDOM = Result
    Exit Function

FileToDOM_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "FileToDOM"
    Resume FileToDOM_Exit

End Function

Private Sub Class_Initialize()

    mvarProgressInterval = 5 ' default ProgressInterval
    mFootText = "End of List"   ' Changed if conversion cancelled

End Sub